home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / fools.lzh / macros.scm < prev    next >
Text File  |  1990-03-02  |  2KB  |  89 lines
  1. ;;; extend-syntax macros
  2.  
  3. (require 'extend-syntax)
  4. (provide 'macros)
  5.  
  6. (extend-syntax (do)
  7.   [(do ([var init . step] ...) (test texp ...) dexp ...)
  8.    (andmap symbol? '(var ...))
  9.    (with ([do-loop (gensym)]
  10.       [(do-step ...)
  11.        (map (lambda (x y)
  12.           (if (null? y) x (car y)))
  13.         '(var ...) '(step ...))])
  14.      (letrec ((do-loop
  15.            (lambda (var ...)
  16.          (if test
  17.              (begin texp ...)
  18.              (begin dexp ... (do-loop do-step ...))))))
  19.        (do-loop init ...)))])
  20.       
  21. (extend-syntax (record-case else)
  22.   [(record-case val (else exp ...))
  23.    (begin exp ...)]
  24.   [(record-case val clause ...)
  25.    (pair? 'val)
  26.    (with ([temp (gensym)])
  27.      (let ([temp val])
  28.        (record-case temp clause ...)))]
  29.   [(record-case val (key idspec exp ...) more ...)
  30.    (with ([bindings
  31.        (let parse ([pat 'idspec] [acc 'val] [recs '()])
  32.          (cond ((symbol? pat)
  33.             (cons (list pat acc) recs))
  34.            ((pair? pat)
  35.             (parse (car pat)
  36.                `(car ,acc)
  37.                (parse (cdr pat)
  38.                   `(cdr ,acc)
  39.                   recs)))
  40.            (else recs)))]
  41.       [same? (if (symbol? 'key) eq? eqv?)])
  42.      (if (same? (car val) 'key)
  43.      (let bindings exp ...)
  44.      (record-case val more ...)))]
  45.   [(record-case val) #f])
  46.  
  47. (extend-syntax (define-structure)
  48.   ;; from "The Scheme Programming Language" by R. Kent Dybvig
  49.   [(define-structure (name id1 ...))
  50.    (define-structure (name id1 ...) ())]
  51.   [(define-structure (name id1 ...) ([id2 val] ...))
  52.    (with ([constructor
  53.        (string->symbol (string-append "make-" 'name))]
  54.       [predicate
  55.        (string->symbol (string-append 'name "?"))]
  56.       [(access ...)
  57.        (map (lambda (x)
  58.           (string->symbol (string-append 'name "-" x)))
  59.         '(id1 ... id2 ...))]
  60.       [(assign ...)
  61.        (map (lambda (x)
  62.           (string->symbol
  63.            (string-append "set-" 'name "-" x "!")))
  64.         '(id1 ... id2 ...))]
  65.       [count (length '(name id1 ... id2 ...))])
  66.      (with ([(index ...)
  67.          (let f ([i 1])
  68.            (if (= i 'count)
  69.            '()
  70.            (cons i (f (+ i 1)))))])
  71.        (begin
  72.      (define constructor
  73.        (lambda (id1 ...)
  74.          (let* ([id2 val] ...)
  75.            (vector 'name id1 ... id2 ...))))
  76.      (define predicate
  77.        (lambda (obj)
  78.          (and (vector? obj)
  79.           (= (vector-length obj) count)
  80.           (eq? (vector-ref obj 0) 'name))))
  81.      (define access
  82.        (lambda (obj)
  83.          (vector-ref obj index)))
  84.      ...
  85.      (define assign
  86.        (lambda (obj newval)
  87.          (vector-set! obj index newval)))
  88.      ...)))])
  89.